home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Camelot / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].zip / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].adf / XLisp-Stat / Functions / twobutton.lsp < prev   
Text File  |  1990-10-11  |  2KB  |  62 lines
  1. ; book pp.317-320
  2.  
  3. (require "functions/pressbutton")
  4.  
  5. (defproto twobutton-control-proto () () button-overlay-proto)
  6. (defmeth twobutton-control-proto :size ()
  7.   (let* ((graph (send self :graph))
  8.          (size (call-next-method))
  9.          (side (send graph :text-ascent))
  10.          (gap (floor (/ side 2))))
  11.     (list (+ gap side (first size)) (second size))))
  12. (defmeth twobutton-control-proto :title-start ()
  13.   (let* ((graph (send self :graph))
  14.          (loc (send self :location))
  15.          (title (send self :title))
  16.          (side (send graph :text-ascent))
  17.          (gap (floor (/ side 2))))
  18.      (list (+ (* 3 gap) (* 2 side) (first loc))
  19.            (+ gap side (second loc)))))
  20. (defmeth twobutton-control-proto :button-box (which)
  21.   (let* ((graph (send self :graph))
  22.          (loc (send self :location))
  23.          (side (send graph :text-ascent))
  24.          (gap (floor (/ side 2)))
  25.          (left (case which
  26.                   (+ (+ gap (first loc)))
  27.                   (- (+ (* 2 gap) side (first loc))))))
  28.      (list left (+ gap (second loc)) side side)))
  29. (defmeth twobutton-control-proto :draw-button (which &optional paint)
  30.   (let ((box (send self :button-box which))
  31.         (graph (send self :graph)))
  32.      (cond (paint (apply #'send graph :paint-rect box))
  33.            (t (apply #'send graph :erase-rect box)
  34.               (apply #'send graph :frame-rect box)))))
  35. (defmeth twobutton-control-proto :redraw ()
  36.   (send self :draw-title)
  37.   (send self :draw-button '-)
  38.   (send self :draw-button '+))
  39. (defmeth twobutton-control-proto :point-in-button (x y)
  40.   (let* ((box1 (send self :button-box '-))
  41.          (box2 (send self :button-box '+))
  42.          (left1 (first box1))
  43.          (top (second box1))
  44.          (side (third box1))
  45.          (left2 (first box2)))
  46.       (cond
  47.         ((and (< left1 x (+ left1 side)) (< top y (+ top side)))
  48.           '-)
  49.         ((and (< left2 x (+ left1 side)) (< top y (+ top side)))
  50.           '+))))
  51. (defmeth twobutton-control-proto :do-click (x y m1 m2)
  52.   (let ((graph (send self :graph))
  53.         (which (send self :point-in-button x y)))
  54.      (when which
  55.          (send self :draw-button which t)
  56.          (send self :do-action which (list m1 m2))
  57.          (send graph :while-button-down
  58.                #'(lambda (x y) (send self :do-action which nil)) nil)
  59.          (send self :draw-button which nil)
  60.          t)))
  61. (defmeth twobutton-control-proto :do-action (which mods) nil)
  62.